home *** CD-ROM | disk | FTP | other *** search
/ Graphics Plus / Graphics Plus.iso / libs / phigs / ptk.lha / ptk / fortran / source / demo / toptest.f < prev    next >
Encoding:
Text File  |  1992-09-29  |  5.0 KB  |  173 lines
  1. C--------------------------------------------------------------------------- 
  2.  
  3. C Program name: TopDraw test program.
  4.  
  5. C Author: Gareth Williams
  6.  
  7. C Description:
  8.  
  9. C Modification history : (Version), (Date), (Name), (Description).
  10.  
  11. C 1.0, 1st June 1991, G. Williams, First Version.
  12.  
  13. C 2.0, June 1992, G. Williams, Converted to SunPHIGS 2.0.
  14.  
  15. C----------------------------------------------------------------------------
  16.  
  17.        PROGRAM toptest
  18.  
  19.        include './sunphigs77.h'
  20.        include './sunptk77.h'
  21.  
  22. C--------------------------------------------------------------------------
  23.  
  24.        INTEGER err, minid, maxid
  25.        INTEGER white, black, green, grey
  26.        LOGICAL ptkf_readphinterscript
  27.        INTEGER ptkf_stringtoint
  28.        LOGICAL docolour
  29.  
  30.        implicit undefined (P, p, E, e)
  31.  
  32. C colour or monochrome
  33.        docolour = .TRUE.
  34.               
  35.        print *,('Demonstrating the topdraw module of the 
  36. & PHIGS Toolkit...')
  37.        print *,('Opening SunPHIGS...')
  38.  
  39.        call popph(6, 0)
  40.  
  41. C     create the workstation type (either tool or canvas) 
  42.               
  43. C     open the workstation 
  44.  
  45.        if (ptkf_readphinterscript('../../scripts/openws.scr', 0, 0) .eq.
  46. & .FALSE.) then     
  47.          goto 30
  48.        endif
  49.        
  50.        call psdus(1, PWAITD, PNIVE)
  51.  
  52.        minid = 0
  53.        maxid = 30
  54.        call ptkf_inithashtables()
  55.        call ptkf_createhashtable('structureid', 17, 100)
  56.        call ptkf_createhashtable('label', minid, maxid)
  57.        call ptkf_createhashtable('name', minid, maxid)
  58.        call ptkf_createhashtable('colourindex', 1, 8)
  59.  
  60.        
  61. C     make dummy network 
  62.      
  63.        if (ptkf_readphinterscript('../../scripts/lamp.scr', 
  64. & 0, 0)) then
  65.          call ptkf_createtopology(1, 
  66. & ptkf_stringtoint('structureid', 'lamp'), err)
  67.  
  68.        if (docolour .eq. .TRUE.) then
  69.          call ptkf_setcolourrep(1, 'black')
  70.          call ptkf_setcolourrep(1, 'white')
  71.          call ptkf_setcolourrep(1, 'grey')
  72.          call ptkf_setcolourrep(1, 'green')
  73.          call ptkf_setcolourrep(1, 'red')
  74.          call ptkf_setcolourrep(1, 'blue')
  75.          green = ptkf_stringtoint('colourindex', 'green')
  76.          grey = ptkf_stringtoint('colourindex', 'grey')
  77.          white = ptkf_stringtoint('colourindex', 'white')
  78.          black = ptkf_stringtoint('colourindex', 'black')
  79.          call ptkf_setbackgroundcolourind(1, grey)
  80.          call ptkf_settopologyattrs(1, PFONTTRIPLEX, white,
  81. & black, white, green, white, green)
  82.        endif
  83.  
  84.          call ptkf_posttopology(1, 1, 0.0)
  85.          call prst(1, PALWAY)
  86.          call options()
  87.        endif
  88.  
  89.  30    call pclwk(1)
  90.        call pclph()
  91.  
  92.        STOP
  93.        END
  94.  
  95. C--------------------------------------------------------------------------
  96.  
  97.        SUBROUTINE options()
  98.        CHARACTER*20 commandstr
  99.        INTEGER lencom
  100.        LOGICAL topquit
  101.        REAL echoarea(4)
  102.        INTEGER lldr, pldr
  103.        CHARACTER*80 ldatrec(1), pdatrec(1)
  104.        CHARACTER*80 storename
  105.        INTEGER*4 fileptr, err
  106.        INTEGER ptkf_fopen
  107.        INTEGER ptkf_fclose
  108.  
  109.        include './sunptk77.h'
  110.  
  111.        storename = '../../data/store.dat'
  112.        topquit = .FALSE.
  113.        call ptkf_limit(0.0, 0.25, 0.0, 0.01, echoarea)
  114.  10    call ptkf_readstring(1, 'boxtopology', 
  115. & 'Input command (default = boxtopology) >', echoarea, 20, 
  116. & commandstr, lencom)
  117.        if (commandstr(1:lencom) .eq. 'boxtopology') then
  118.          call ptkf_settopologytype(1, PTKEBOXTOPOLOGY)
  119.  
  120.       else if (commandstr(1:lencom) .eq. 'structnettopology') then
  121.          call ptkf_settopologytype(1, PTKESTRUCTNETTOPOLOGY)
  122.  
  123.       else if (commandstr(1:lencom) .eq. 'structtopology') then
  124.          call ptkf_settopologytype(1, PTKESTRUCTTOPOLOGY)
  125.  
  126.       else if (commandstr(1:lencom) .eq. 'tidysingle') then
  127.          ldr = 0
  128.          pdr = 0
  129.          call ptkf_tidytopology(1, 1, PTKESINGLE, 1, 1, pldr, pdatrec,
  130. & 1, 1, lldr, ldatrec)
  131.  
  132.       else if (commandstr(1:lencom) .eq. 'tidygroup') then
  133.          ldr = 0
  134.          pdr = 0
  135.          call ptkf_tidytopology(1, 1,PTKEGROUP, 1, 1, pldr, pdatrec,
  136. & 1, 1, lldr, ldatrec)
  137.  
  138.       else if (commandstr(1:lencom) .eq. 'store') then
  139.          fileptr = ptkf_fopen(storename, 'w+')
  140.          print *,'storing layout in', storename
  141.          print *,('Testing ptkf_storetopologylayout()...')
  142.          call ptkf_storetopologylayout(fileptr, 1)
  143.          err = ptkf_fclose(fileptr)
  144.  
  145.       else if (commandstr(1:lencom) .eq. 'restore') then
  146.          fileptr = ptkf_fopen(storename, 'r')
  147.          print *,'restoring layout from', storename
  148.          print *,('Testing ptkf_restoretopologylayout()...')
  149.          call ptkf_restoretopologylayout(fileptr, 1) 
  150.          err = ptkf_fclose(fileptr)
  151.  
  152.       else if (commandstr(1:lencom) .eq. 'quit') then
  153.          topquit = .TRUE.
  154.  
  155.       else
  156.          print *,('Command unknown')    
  157.       endif
  158.  
  159.        call prst(1, PALWAY)
  160.  
  161.        if (topquit .eq. .TRUE.) then
  162.          goto 20
  163.        else 
  164.          goto 10
  165.        endif
  166.  
  167.  20    RETURN
  168.        END
  169.                  
  170. C--------------------------------------------------------------------------
  171.          
  172. C     end of toptest.f
  173.